home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1996 January / macformat-033.iso / mac / Shareware City / Developers / CGIshell Folder / Pocket 6.4 / Examples / TextEdit < prev   
Encoding:
Text File  |  1992-08-14  |  8.4 KB  |  187 lines  |  [TEXT/McSk]
  1. ( text edit example for Pocket Forth 0.6 or 1.6  18:06 6/9/91 )
  2. forget task : task ; decimal
  3. page 0 28 +md !  ( kill echo )
  4.  
  5. ( text edit record handle )
  6. 2variable TERECORD  ( pronounced "terra chord" )
  7. : TEH ( -- dhandle ) terecord 2@ ;  ( the TE record handle )
  8.  
  9. ( te toolbox routines )
  10. : TENEW ( -- ) ( initialize the TE record )
  11.     0 0 2>r  ( room for result from toolbox function )
  12.     4 +md a>r  ( push dest rect address to rstack )
  13.     4 +md a>r  (  "   view  "     "     "    "    )
  14.     ,$ A9D2  2r>  ( _TENew then pop handle from rstack )
  15.     terecord 2! ;  ( store the handle away for later )
  16. : TESETTEXT ( addr len -- ) ( set text to string from stack )
  17.     swap a>r  ( push string address to rstack )
  18.     s>d 2>r  ( push 32 bit string length to rstack )
  19.     teh 2>r  ( push the terecord's handle to rstack )
  20.     ,$ A9CF ;  ( _TESetText )
  21. : TEGETTEXT ( -- dhandle ) ( get a handle to the text )
  22.     0 0 2>r  ( room for the text handle )
  23.     teh 2>r  ( push the terecord's handle to rstack )
  24.     ,$ A9CB 2r> ;  ( _TEGetText, pop handle from rstack )
  25. : TELENGTH ( -- n ) ( get the length of the text )
  26.     teh dl@  ( get pointer to the text )
  27.     60 s>d d+  ( add teLength offset to pointer )
  28.     l@ ;  ( fetch length value )
  29. : TECLICK ( -- ) ( handle a click in the TE's rect )
  30.     @mouse 2>r  ( push the _current_ mouse position to rstack )
  31.     0 >r  ( not an extended click )
  32.     teh 2>r  ( push the terecord's handle to rstack )
  33.     ,$ A9D4 ;  ( _TEClick )
  34. : TEKEY ( c -- ) ( handle a character from the stack )
  35.     >r  ( push the character to the rstack )
  36.     teh 2>r ,$ A9DC ;  ( push handle _TEKey )
  37. : TEUPDATE ( -- ) ( draw the editable text )
  38.     4 +md a>r ( push the view rect's address to rstack )
  39.     teh 2>r  ,$ A9D3 ;  ( push handle _TEUpdate )
  40. : TEACTIVATE ( -- ) ( show selection, etc. )
  41.     teh 2>r  ,$ A9D8 ;  ( push handle _TEActivate )
  42. : TEDEACTIVATE ( -- ) ( hide selection, etc. )
  43.     teh 2>r  ,$ A9D9 ;  ( push handle _TEActivate )
  44. : TEIDLE ( -- ) ( blink the cursor )
  45.     teh 2>r  ,$ A9DA ;  ( push handle _TEIdle )
  46. : TECUT ( -- ) teh 2>r ,$ A9D6 ;  ( push handle _TECut )
  47. : TECOPY ( -- ) teh 2>r ,$ A9D5 ;  ( push handle _TECopy )
  48. : TEPASTE ( -- ) teh 2>r ,$ A9DB ;  ( push handle _TEPaste )
  49. : TEDISPOSE ( -- ) teh 2>r ,$ A9CD ;  ( push handle _TEDispose )
  50.  
  51. ( private te scrap to clipboard conversion )
  52. : "TEXT" ( -- d'TEXT' ) [ 22612 21573 dliteral ] ; macro
  53. : TEFROMSCRAP ( -- ) ( move clipboard contents to TE scrap )
  54.     0 0 2>r  ( room on rstack for toolbox function result )
  55.     2740 0 dl@ 2>r  ( push TEScrpHandle to rstack )
  56.     "text" 2>r  ( scrap type identifier )
  57.     here a>r  ( here is used as a temporary variable )
  58.       ,$ A9FD  ( _GetScrap )
  59.     2r> 0< IF  ( just test the high byte )
  60.       drop beep  ( drop error code & beep )
  61.     ELSE  2736 0 l!  THEN ;  ( set TEScrpLength )
  62. : TETOSCRAP ( -- ) ( move TE scrap to clipboard )
  63.     0 0 2>r  ( room on rstack for toolbox function result )
  64.      ,$ A9FC  ( _ZeroScrap )
  65.     2736 0 l@ 0 2>r  ( push TEScrpLength to rstack )
  66.     "text" 2>r  ( scrap type identifier )
  67.     2740 0 dl@ dl@ 2>r  ( double dereference TEScrpHandle )
  68.       ,$ A9FE  ( _PutScrap )
  69.     2r> + IF beep THEN ;  ( beep if error )
  70.  
  71. ( activate and edit menu handlers )
  72. : MYACT ( f -- ) IF teactivate ELSE tedeactivate THEN ;
  73. : EDITMENU ( n -- addr ) ( item to address, undo is 0 )
  74.     18 +md @ 2+ @ swap 2* + ;
  75. : CUT ( -- ) tecut tetoscrap ;
  76. : COPY ( -- ) tecopy tetoscrap ;
  77. : PASTE ( -- ) tefromscrap tepaste ;
  78.  
  79. ( string compilation )
  80. : EVEN ( n -- n' ) dup 2 mod + ;  ( round n up to an even number )
  81. : ," ( -- ) ( compile a quoted string from input stream )
  82.     34 word here c@ 1+ even allot ; immediate
  83.  
  84. ( a string )
  85. create INTRO ( -- addr ) ( some text to edit )
  86.     ," Press 'Enter' to quit, hold option key to save."
  87.  
  88. : NOCURSOR ( -- ) ( don't draw the little line cursor )
  89.     20085 14 +md @ ! ;  ( replace cursor routine with RTS )
  90. : !EDIT ( -- ) ( set input routines to edit text )
  91.     nocursor  page  ( prepare the window )
  92.     [ ' teclick literal ] 16 +md !  ( set button handler )
  93.     [ ' teidle literal ] 20 +md !  ( set idle handler )
  94.     [ ' teupdate literal ] 14 +md !  ( set update handler )
  95.     [ ' myact literal ] 12 +md !  ( set activate handler )
  96.     [ ' cut literal ] 2 editmenu !  ( set cut )
  97.     [ ' copy literal ] 3 editmenu !  ( set copy )
  98.     [ ' paste literal ] 4 editmenu !  ( set paste )
  99.     intro count tesettext ;  ( set the initial text to edit )
  100. : !INTERPRET ( -- ) ( reset the interpreter handlers )
  101.     [ ' beep literal ] 16 +md !  ( reset button handler )
  102.     [ ' null literal ] 20 +md !  ( reset idle handler )
  103.     [ 14 +md @ literal ] 14 +md !  ( reset update )
  104.     [ ' drop literal ] 12 +md !  ( reset activate )
  105.     [ ' beep literal ] 2 editmenu !  ( reset cut )
  106.     [ ' beep literal ] 3 editmenu !  ( reset copy )
  107.     [ 4 editmenu @ literal ] 4 editmenu !  ( reset paste )
  108.     [ 14 +md @ @ literal ] 14 +md @ ! ;  ( reset cursor )
  109.  
  110. ( This part is from the Release 4 file "DataFiles". )
  111. variable FCB 78 allot  ( the file control block )
  112. : +FCB ( offset -- addr ) fcb + ;  ( offset into fcb )
  113. : 0FCB ( -- ) fcb 80 0 fill ;  ( clear the fcb )
  114. : FTRAP ( -- ) fcb >abs  ,$ 205E ;  ( movea.l [ps]+,a0 )
  115. : CLOSE ( -- ) ftrap ,$ A001  ftrap ,$ A013 ;  ( close & flush )
  116. : ?DERROR ( -- ) ( nothing if no error, quit if disk error )
  117.      16 +fcb @ ?dup IF  ( if result not zero )
  118.       ." DiskError" .  close  abort THEN ;  ( report & abort )
  119. : !SIZE ( bytes -- ) 38 +fcb ! ;  ( set bytes-to-read or write )
  120. : !NAME ( name.addr -- ) >abs  0fcb  18 +fcb  2! ;  ( set name )
  121. : !TYPE ( dtype -- ) 32 +fcb 2!  ( set the file type )
  122.     ftrap ,$ A00D ?derror ;  ( _SetFileInfo )
  123.  
  124. create FILENAME ( -- name.addr ) ," Pocket Text" 54 allot
  125. create PROMPTSTR ( -- addr ) ," Save the text as:"
  126. : NEW ( name.addr -- ) ( create a file, or replace an existing one )
  127.     pad 74 0 fill  ( clean out pad )
  128.     55 75 2>r  ( top left corner )
  129.     promprstr a>r  filename a>r  ( prompt and default file name )
  130.     0 0 2>r  pad a>r  ( reply record address [at pad] )
  131.     1 >r  ,$ a9ea  ( _SFPutFile )
  132.     pad 10 + !name  ( set the file name )
  133.     pad 6 + @  22 +fcb !  ( set vrefnum )
  134.     ftrap ,$ A008  ( _Create )
  135.     16 +fcb @ -48 = 0= IF  ( This line has been added to ... )
  136.       ?derror THEN ;  ( ... ignore duplicate file name errors. )
  137. : OPEN ( -- ) ftrap ,$ A000  ?derror ;  ( _Open the file )
  138. : WRITE ( dabs.addr -- ) ( write to file from absolute address )
  139.     32 +fcb 2!  ( set write buffer pointer )
  140.     ftrap ,$ A003  ?derror ;  ( _Write )
  141.  
  142. : SAVETEXT ( -- ) ( save the text to the file )
  143.     new open  ( create a new file and open it )
  144.       "text" !type  ( set file type to TEXT )
  145.       telength !size  ( set the number of bytes to write )
  146.       tegettext dl@ write  ( send the text to the file )
  147.     close ;  ( close the file )
  148. ( If an I/O error occurs, type:  !interpret tedispose  )
  149.  
  150. ( event record access / command key test )
  151. : ?DA ( -- flag ) ( true if the DA type is running )
  152.     0 +md 2@  ( the window's pointer )
  153.     108 0 d+ l@  0< ; ( the windowKind integer<0 if DA kind )
  154. : +ERECORD ( offset -- dabs.addr ) ( access the event record )
  155.     ?da IF  ( is it the DA )
  156.       ,$ 2044  ( movea.l d4,a0 ) ( D4 has parameter block address )
  157.       ,$ 2D28 ,$ 1C  ( move.l csParams[a0],-[ps] ) ( push address )
  158.     ELSE  148 +md >abs  ( address is in +md array )
  159.     THEN  rot 0 d+ ;  ( double.offset + erecord dabs.addr )
  160. : META ( -- n ) 14 +erecord l@ ;  ( get meta keys word )
  161. : ?CMD ( -- flag ) meta 256 and ;  ( true if clover key is down )
  162. : ?OPTION ( -- flag ) meta 2048 and ;  ( true if option key is down )
  163. : COMMANDKEYS ( c -- ) ( do command key handlers )
  164.     >r  ( hold the character on the return stack )
  165.     r 120 = IF cut ELSE  ( if character = x then cut )
  166.       r 99 = IF copy ELSE  ( if character = c then copy )
  167.         r 118 = IF paste THEN  ( if character = v then paste )
  168.     THEN THEN  r> drop ;  ( pop and drop the character )
  169.  
  170. : EDIT ( -- ) ( run the demo )
  171.     tenew  ( create the text edit record )
  172.       !edit ( set the text edit event handlers )
  173.       teupdate  ( draw the existing text )
  174.       teactivate  ( start editing text )
  175.         BEGIN
  176.           key dup  ( get a key )
  177.         3 > WHILE  ( until "enter" is pressed )
  178.           ?cmd IF  ( check cmd key )
  179.             commandkeys ELSE tekey THEN  ( handle key presses )
  180.         REPEAT drop
  181.       tedeactivate  ( turn off text editing )
  182.       !interpret  ( reset the standard event handlers )
  183.       ?option IF savetext THEN ( save the text to a file )
  184.     tedispose ;  ( get rid of the text edit record )
  185.  
  186. -1 28 +md !  edit
  187.